home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / Marlais 0.5.9-portable sources / syntax.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  51.1 KB  |  2,074 lines  |  [TEXT/ttxt]
  1. /*
  2.  
  3.    syntax.c
  4.  
  5.    This software is free software; you can redistribute it and/or
  6.    modify it under the terms of the GNU Library General Public
  7.    License as published by the Free Software Foundation; either
  8.    version 2 of the License, or (at your option) any later version.
  9.  
  10.    This software is distributed in the hope that it will be useful,
  11.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.    Library General Public License for more details.
  14.  
  15.    You should have received a copy of the GNU Library General Public
  16.    License along with this software; if not, write to the Free
  17.    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.    Original copyright notice follows:
  20.  
  21.    Copyright, 1993, Brent Benson.  All Rights Reserved.
  22.    0.4 & 0.5 Revisions Copyright 1994, Joseph N. Wilson.  All Rights Reserved.
  23.  
  24.    Permission to use, copy, and modify this software and its
  25.    documentation is hereby granted only under the following terms and
  26.    conditions.  Both the above copyright notice and this permission
  27.    notice must appear in all copies of the software, derivative works
  28.    or modified version, and both notices must appear in supporting
  29.    documentation.  Users of this software agree to the terms and
  30.    conditions set forth in this notice.
  31.  
  32.  */
  33.  
  34. #include <string.h>
  35.  
  36. #include "syntax.h"
  37.  
  38. #include "alloc.h"
  39. #include "apply.h"
  40. #include "boolean.h"
  41. #include "bytestring.h"
  42. #include "class.h"
  43. #include "env.h"
  44. #include "error.h"
  45. #include "eval.h"
  46. #include "keyword.h"
  47. #include "list.h"
  48. #include "function.h"
  49. #include "misc.h"
  50. #include "number.h"
  51. #include "print.h"
  52. #include "symbol.h"
  53. #include "table.h"
  54. #include "values.h"
  55.  
  56. extern Object dylan_symbol;
  57. extern Object dylan_user_symbol;
  58. extern Object modifiers_keyword;
  59. extern Object abstract_symbol;
  60. extern Object concrete_symbol;
  61. extern Object primary_symbol;
  62. extern Object free_symbol;
  63. extern Object open_symbol;
  64. extern Object sealed_symbol;
  65. extern Object description_symbol;
  66. extern Object error_class;
  67.  
  68. /* data structures */
  69.  
  70. struct syntax_entry {
  71.     Object sym;
  72.     syntax_fun fun;
  73.     struct syntax_entry *next;
  74. };
  75.  
  76. #define SYNTAX_TABLE_SIZE 1024
  77. struct syntax_entry *syntax_table[SYNTAX_TABLE_SIZE];
  78.  
  79. /* local variables and functions */
  80.  
  81. void install_syntax_entry (char *name, syntax_fun fun);
  82. void bind_variables (Object init_list, int top_level, int constant);
  83. void add_variable_binding (Object var,
  84.                Object val,
  85.                int top_level,
  86.                int constant);
  87.  
  88. /* functions emobodying evaluation rules for forms */
  89.  
  90. static Object and_eval (Object form);
  91. static Object car (Object lst);
  92. static Object begin_eval (Object form);
  93. static Object bind_eval (Object form);
  94. static Object bind_exit_eval (Object form);
  95. static Object bind_methods_eval (Object form);
  96. static Object boundp_eval (Object form);
  97. static Object case_eval (Object form);
  98. static Object cond_eval (Object form);
  99. static Object define_eval (Object form);
  100. static Object define_constant_eval (Object form);
  101. static Object define_class_eval (Object form);
  102. static Object define_generic_function_eval (Object form);
  103. static Object define_method_eval (Object form);
  104. static Object define_module_eval (Object form);
  105. static Object define_test_eval (Object form);
  106. static Object dotimes_eval (Object form);
  107. static Object for_eval (Object form);
  108. static Object get_variable (Object var_spec);
  109. static void get_vars_and_inits (Object var_forms,
  110.                 Object *clause_types_ptr,
  111.                 Object *vars_ptr,
  112.                 Object *inits_ptr);
  113. static void initialize_step_and_numeric_vars (Object clause_types,
  114.                           Object vars,
  115.                           Object inits);
  116. static void initialize_collection_inits (Object clause_types,
  117.                      Object vars,
  118.                      Object inits);
  119.  
  120. static void initialize_numeric_and_collection_clauses (Object clause_types,
  121.                                Object vars,
  122.                                Object inits);
  123. static int exhausted_numeric_or_collection_clauses (Object clause_types,
  124.                             Object vars,
  125.                             Object inits,
  126.                             int init_call);
  127. static void initialize_collection_variables (Object clause_types,
  128.                          Object vars,
  129.                          Object inits);
  130. static void update_explicit_and_numeric_clauses (Object clause_types,
  131.                          Object vars,
  132.                          Object inits);
  133. static void update_collection_variables (Object clause_types,
  134.                      Object vars,
  135.                      Object inits);
  136. static Object for_each_eval (Object form);
  137. static Object if_eval (Object form);
  138. static Object method_eval (Object form);
  139. static Object or_eval (Object form);
  140. static Object quasiquote_eval (Object form);
  141. static Object quote_eval (Object form);
  142. static Object select_eval (Object form);
  143. static Object set_eval (Object form);
  144. static Object set_module_eval (Object form);
  145. static Object unless_eval (Object form);
  146. static Object until_eval (Object form);
  147. static Object unwind_protect_eval (Object form);
  148. static Object when_eval (Object form);
  149. static Object while_eval (Object form);
  150. static Object local_bind_eval (Object form);
  151. static Object unbinding_begin_eval (Object form);
  152.  
  153. static Object process_test_result (Object name, Object options,
  154.                    Object doc_string, Object result);
  155. static Object record_failure (Object name, Object doc_string, Object result);
  156. static Object record_success (Object name, Object doc_string, Object result);
  157. static Object record_disabled (Object name, Object doc_string);
  158.  
  159.  
  160. static char *syntax_operators[] =
  161. {
  162.     "and",
  163.     "&",
  164.     "begin",
  165.     "bind",
  166.     "bind-exit",
  167.     "bind-methods",
  168.     "bound?",
  169.     "case",
  170.     "cond",
  171.     "define",
  172.     "define-variable",
  173.     "define-class",
  174.     "define-constant",
  175.     "define-generic-function",
  176.     "define-method",
  177.     "define-module",
  178.     "define-test",
  179.     "dotimes",
  180.     "for",
  181.     "for-each",
  182.     "if",
  183.     "method",
  184.     "or",
  185.     "|",
  186.     "quasiquote",
  187.     "quote",
  188.     "select",
  189.     "set!",
  190.     "set-module",
  191.     "unless",
  192.     "until",
  193.     "unwind-protect",
  194.     "when",
  195.     "while",
  196.     "\"local-bind",
  197.     "\"unbinding-begin",
  198. };
  199.  
  200. static syntax_fun syntax_functions[] =
  201. {
  202.     and_eval,
  203.     and_eval,
  204.     begin_eval,
  205.     bind_eval,
  206.     bind_exit_eval,
  207.     bind_methods_eval,
  208.     boundp_eval,
  209.     case_eval,
  210.     cond_eval,
  211.     define_eval,
  212.     define_eval,
  213.     define_class_eval,
  214.     define_constant_eval,
  215.     define_generic_function_eval,
  216.     define_method_eval,
  217.     define_module_eval,
  218.     define_test_eval,
  219.     dotimes_eval,
  220.     for_eval,
  221.     for_each_eval,
  222.     if_eval,
  223.     method_eval,
  224.     or_eval,
  225.     or_eval,
  226.     quasiquote_eval,
  227.     quote_eval,
  228.     select_eval,
  229.     set_eval,
  230.     set_module_eval,
  231.     unless_eval,
  232.     until_eval,
  233.     unwind_protect_eval,
  234.     when_eval,
  235.     while_eval,
  236.     local_bind_eval,
  237.     unbinding_begin_eval,
  238. };
  239.  
  240. void
  241. init_syntax_table (void)
  242. {
  243.     int numops, i;
  244.     Object symbol;
  245.  
  246.     numops = sizeof (syntax_operators) / sizeof (char *);
  247.  
  248.     for (i = 0; i < numops; ++i) {
  249.     install_syntax_entry (syntax_operators[i],
  250.                   syntax_functions[i]);
  251.     }
  252. }
  253.  
  254. syntax_fun
  255. syntax_function (Object sym)
  256. {
  257.     struct syntax_entry *entry;
  258.     int h;
  259.  
  260.     h = ((int) sym) % SYNTAX_TABLE_SIZE;
  261.     entry = syntax_table[h];
  262.     while (entry) {
  263.     if (entry->sym == sym) {
  264.         return (entry->fun);
  265.     }
  266.     entry = entry->next;
  267.     }
  268.     return (NULL);
  269. }
  270.  
  271. void
  272. install_syntax_entry (char *name, syntax_fun fun)
  273. {
  274.     struct syntax_entry *entry;
  275.     Object sym;
  276.     int h;
  277.  
  278.     sym = make_symbol (name);
  279.     h = ((int) sym) % SYNTAX_TABLE_SIZE;
  280.     entry = (struct syntax_entry *)
  281.     checking_malloc (sizeof (struct syntax_entry));
  282.  
  283.     entry->sym = sym;
  284.     entry->fun = fun;
  285.     entry->next = syntax_table[h];
  286.     syntax_table[h] = entry;
  287. }
  288.  
  289. /* <pcb> a single function to evaluate bodies. uses tail_eval. */
  290.  
  291. static Object
  292. eval_body (Object body, Object null_body_result_value)
  293. {
  294.     Object result = null_body_result_value;
  295.  
  296.     while (!NULLP (body)) {
  297.     Object next = CDR (body);
  298.  
  299.     if (NULLP (next)) {
  300.         result = tail_eval (CAR (body));
  301.     } else {
  302.         result = eval (CAR (body));
  303.     }
  304.     body = next;
  305.     }
  306.  
  307.     return result;
  308. }
  309.  
  310. /* functions that perform the special evaluation
  311.    rules for syntax forms. */
  312.  
  313. static Object
  314. and_eval (Object form)
  315. {
  316.     Object clauses, ret;
  317.     int i;
  318.  
  319.     clauses = CDR (form);
  320.     while (!NULLP (clauses)) {
  321.     ret = eval (CAR (clauses));
  322.     if (VALUESP (ret)) {
  323.         if (PAIRP (CDR (clauses))) {
  324.         ret = FIRSTVAL (ret);
  325.         } else {
  326.         return ret;
  327.         }
  328.     }
  329.     if (ret == false_object) {
  330.         return (false_object);
  331.     }
  332.     clauses = CDR (clauses);
  333.     }
  334.     return (ret);
  335. }
  336.  
  337. static Object
  338. begin_eval (Object form)
  339. {
  340.     return eval_body (CDR (form), unspecified_object);
  341. }
  342.  
  343. static Object
  344. bind_eval (Object form)
  345. {
  346.     Object bindings, body, binding, var, val, res;
  347.     Object first, last, new, type;
  348.     int value_count, i;
  349.  
  350.     if (NULLP (CDR (form))) {
  351.     error ("malformed bind form", form, NULL);
  352.     }
  353.     bindings = SECOND (form);
  354.     body = CDR (CDR (form));
  355.  
  356.     push_scope (CAR (form));
  357.     while (!NULLP (bindings)) {
  358.     bind_variables (CAR (bindings), 0, 0);
  359.     bindings = CDR (bindings);
  360.     }
  361.  
  362.     res = eval_body (body, unspecified_object);
  363.     pop_scope ();
  364.     return (res);
  365.  
  366. }
  367.  
  368. static Object
  369. local_bind_eval (Object form)
  370. {
  371.     Object bindings, body, binding, var, val, res;
  372.     Object first, last, new, type;
  373.     int value_count, i;
  374.  
  375.     if (NULLP (CDR (form))) {
  376.     error ("malformed local binding", form, NULL);
  377.     }
  378.     bindings = SECOND (form);
  379.  
  380.     push_scope (CAR (form));
  381.     while (!NULLP (bindings)) {
  382.     bind_variables (CAR (bindings), 0, 0);
  383.     bindings = CDR (bindings);
  384.     }
  385.     return unspecified_object;
  386. }
  387.  
  388. /*
  389.  * Hacked together to make infix begin work with strange "let" forms
  390.  */
  391. static Object
  392. unbinding_begin_eval (Object form)
  393. {
  394.     int i;
  395.     Object res;
  396.  
  397.     if (list_length (form) < 2) {
  398.     error ("Bad unbinding-begin form", form, NULL);
  399.     }
  400.     i = INTVAL (SECOND (form));
  401.  
  402.     res = unspecified_object;
  403.     form = CDR (CDR (form));
  404.     while (PAIRP (form)) {
  405.     Object next_form = CDR (form);
  406.  
  407.     if (NULLP (next_form)) {
  408.         res = tail_eval (CAR (form));
  409.     } else {
  410.         res = eval (CAR (form));
  411.     }
  412.     form = next_form;
  413.     }
  414.  
  415.     while (i-- > 0) {
  416.     pop_scope ();
  417.     }
  418.  
  419.     return res;
  420. }
  421.  
  422. static Object
  423. bind_exit_eval (Object form)
  424. {
  425.     Object exit_obj, sym, body, ret, val, sec;
  426.     jmp_buf buf;
  427.  
  428.     if (NULLP (CDR (form))) {
  429.     error ("malformed bind-exit form", form, NULL);
  430.     }
  431.     sec = SECOND (form);
  432.     if (!PAIRP (sec)) {
  433.     error ("bind-exit: second argument must be a list containing a symbol", sec, NULL);
  434.     }
  435.     sym = CAR (sec);
  436.     body = CDR (CDR (form));
  437.     if (!SYMBOLP (sym)) {
  438.     error ("bind-exit: bad exit procedure name", sym, NULL);
  439.     }
  440.     exit_obj = make_exit (sym);
  441.     ret = (Object) setjmp (*EXITRET (exit_obj));
  442.     push_scope (CAR (form));
  443.     add_binding (sym, exit_obj, 1);
  444.     if (!ret) {
  445.     ret = false_object;
  446.     while (!NULLP (body)) {
  447.         ret = eval (CAR (body));
  448.         body = CDR (body);
  449.     }
  450.     pop_scope ();
  451.     return (ret);
  452.     } else {
  453.     pop_scope ();
  454.     return (ret);
  455.     }
  456. }
  457.  
  458. static Object
  459. bind_methods_eval (Object form)
  460. {
  461.     Object specs, body, spec, ret;
  462.     Object name, params, method_body, method;
  463.  
  464.     if (NULLP (CDR (form))) {
  465.     error ("bind-methods: bad form", form, NULL);
  466.     }
  467.     specs = SECOND (form);
  468.     body = CDR (CDR (form));
  469.  
  470.     push_scope (CAR (form));
  471.     /* first bind method names to dummy values */
  472.     if (!PAIRP (specs)) {
  473.     error ("bind-methods: First argument must be a list of method bindings",
  474.            specs,
  475.            NULL);
  476.     }
  477.     while (!NULLP (specs)) {
  478.     spec = CAR (specs);
  479.     name = FIRST (spec);
  480.     add_binding (name, false_object, 0);
  481.     specs = CDR (specs);
  482.     }
  483.  
  484.     /* now, actually make the methods */
  485.     specs = SECOND (form);
  486.     while (!NULLP (specs)) {
  487.     spec = CAR (specs);
  488.     name = FIRST (spec);
  489.     if (EMPTYLISTP (CDR (spec))) {
  490.         error ("bind-methods: incomplete method specification",
  491.            spec,
  492.            NULL);
  493.     }
  494.     params = SECOND (spec);
  495.     method_body = CDR (CDR (spec));
  496.     method = make_method (name, params, method_body, the_env, 0);
  497.     modify_value (name, method);
  498.     specs = CDR (specs);
  499.     }
  500.  
  501.     ret = eval_body (body, unspecified_object);
  502.     pop_scope ();
  503.     return (ret);
  504. }
  505.  
  506. static Object
  507. boundp_eval (Object form)
  508. {
  509.     Object cdr = CDR (form);
  510.     Object sym;
  511.  
  512.     if (NULLP (cdr)) {
  513.     error ("bound?: missing symbol", form, NULL);
  514.     }
  515.     sym = CAR (cdr);
  516.     if (!SYMBOLP (sym)) {
  517.     error ("bound?: argument must be a symbol", sym, NULL);
  518.     }
  519.     return (symbol_value (sym) == NULL ? false_object : true_object);
  520. }
  521.  
  522. static Object
  523. case_eval (Object form)
  524. {
  525.     Object target_form, branches, branch;
  526.     Object match_list, consequents, ret;
  527.  
  528.     if (NULLP (CDR (form))) {
  529.     error ("malformed case", form, NULL);
  530.     }
  531.     target_form = eval (CAR (CDR (form)));
  532.  
  533.     if (NULLP (CDR (CDR (form)))) {
  534.     error ("malformed case", form, NULL);
  535.     }
  536.     branches = CDR (CDR (form));
  537.     while (!NULLP (branches)) {
  538.     branch = CAR (branches);
  539.     if (!PAIRP (branch)) {
  540.         error ("case: malformed branch", branch, NULL);
  541.     }
  542.     match_list = CAR (branch);
  543.     if ((match_list == true_object) || (match_list == else_keyword)) {
  544.         consequents = CDR (branch);
  545.         ret = false_object;
  546.         while (!NULLP (consequents)) {
  547.         ret = eval (CAR (consequents));
  548.         consequents = CDR (consequents);
  549.         }
  550.         return (ret);
  551.     }
  552.     if (!PAIRP (match_list)) {
  553.         error ("select: malformed test expression", match_list, NULL);
  554.     }
  555.     while (!NULLP (match_list)) {
  556.         if (id_p (CAR (match_list), target_form, make_empty_list ())
  557.         != false_object) {
  558.         consequents = CDR (branch);
  559.         ret = false_object;
  560.         while (!NULLP (consequents)) {
  561.             ret = eval (CAR (consequents));
  562.             consequents = CDR (consequents);
  563.         }
  564.         return (ret);
  565.         }
  566.         match_list = CDR (match_list);
  567.     }
  568.     branches = CDR (branches);
  569.     }
  570.     error ("case: no matching clause", target_form, NULL);
  571. }
  572.  
  573. static Object
  574. cond_eval (Object form)
  575. {
  576.     Object clauses, clause, test, ret;
  577.  
  578.     clauses = CDR (form);
  579.     while (!NULLP (clauses)) {
  580.     clause = CAR (clauses);
  581.     test = CAR (clause);
  582.     ret = eval (test);
  583.     if (VALUESP (ret)) {
  584.         ret = FIRSTVAL (ret);
  585.     }
  586.     if (ret != false_object) {
  587.         clause = CDR (clause);
  588.         return eval_body (clause, ret);
  589.     }
  590.     clauses = CDR (clauses);
  591.     }
  592.     return (false_object);
  593. }
  594.  
  595. static Object
  596. define_eval (Object form)
  597. {
  598.     Object sym, val;
  599.  
  600.     if (NULLP (CDR (form)) || NULLP (CDR (CDR (form)))) {
  601.     error ("DEFINE form requires at least two args: (define {<var>} <init>)", form, NULL);
  602.     } else {
  603.     bind_variables (CDR (form), 1, 0);
  604.     }
  605.     return unspecified_object;
  606. }
  607.  
  608.  
  609. static Object
  610. define_constant_eval (Object form)
  611. {
  612.     Object sym, val;
  613.  
  614.     if (NULLP (CDR (form)) || NULLP (CDR (CDR (form)))) {
  615.     error ("DEFINE form requires at least two args: (define {<var>} <init>)", form, NULL);
  616.     } else {
  617.     bind_variables (CDR (form), 1, 1);
  618.     }
  619.     return SECOND (form);
  620. }
  621.  
  622. void
  623. bind_variables (Object init_list, int top_level, int constant)
  624. {
  625.     Object variable, variables, init, val;
  626.     Object first, last, new;
  627.     int i, value_count;
  628.  
  629.     if (!PAIRP (init_list) || NULLP (CDR (init_list))) {
  630.     error ("Initializer list requires at least two elements",
  631.            init_list, NULL);
  632.     }
  633.     variables = init = init_list;
  634.     while (!NULLP (CDR (init))) {
  635.     init = CDR (init);
  636.     }
  637.     val = eval (CAR (init));
  638.     if (VALUESP (val)) {
  639.     value_count = 0;
  640.     while (variables != init) {
  641.         variable = CAR (variables);
  642.         if (variable == hash_rest_symbol) {
  643.         variable = SECOND (variables);
  644.         last = NULL;
  645.         first = make_empty_list ();
  646.         /* bind rest values */
  647.         for (i = value_count; i < VALUESNUM (val); ++i) {
  648.             new = cons (VALUESELS (val)[i], make_empty_list ());
  649.             if (last) {
  650.             CDR (last) = new;
  651.             } else {
  652.             first = new;
  653.             }
  654.             last = new;
  655.         }
  656.         if (top_level) {
  657.             add_top_level_binding (variable, first, constant);
  658.         } else {
  659.             add_binding (variable, first, constant);
  660.         }
  661.         /* check for no variables after #rest */
  662.         if (CDR (CDR (variables)) != init) {
  663.             error ("Badly placed #rest specifier", init_list, NULL);
  664.         }
  665.         /* finished with bindings */
  666.         break;
  667.         } else {
  668.         /* check for not enough inits */
  669.         if (value_count < VALUESNUM (val)) {
  670.             new = VALUESELS (val)[value_count];
  671.         } else {
  672.             new = false_object;
  673.         }
  674.         add_variable_binding (variable, new, top_level, constant);
  675.         value_count++;
  676.         }
  677.         variables = CDR (variables);
  678.     }
  679.     } else {
  680.     add_variable_binding (CAR (variables), val, top_level, constant);
  681.     for (variables = CDR (variables);
  682.          variables != init;
  683.          variables = CDR (variables)) {
  684.         add_variable_binding (CAR (variables),
  685.                   false_object,
  686.                   top_level,
  687.                   constant);
  688.     }
  689.     }
  690. }
  691.  
  692. void
  693. add_variable_binding (Object var, Object val, int top_level, int constant)
  694. {
  695.     Object type;
  696.  
  697.     if (PAIRP (var)) {
  698.     if (!PAIRP (CDR (var))) {
  699.         error ("badly formed variable", var, NULL);
  700.     }
  701.     type = eval (SECOND (var));
  702.     if (!instance (type, type_class)) {
  703.         error ("badly formed variable", var, NULL);
  704.     }
  705.     } else {
  706.     type = object_class;
  707.     }
  708.     if (!instance (val, type)) {
  709.     error ("init value does not satisfy type constraint", val, type, NULL);
  710.     }
  711.     if (top_level) {
  712.     add_top_level_binding (var, val, constant);
  713.     } else {
  714.     add_binding (var, val, constant);
  715.     }
  716. }
  717.  
  718. static Object
  719. define_class_eval (Object form)
  720. {
  721.     Object name, supers, slots, class, obj, modifiers, modifier;
  722.  
  723.     /*
  724.      * Assume a class to be concrete, sealed, and free unless otherwise
  725.      * specified
  726.      */
  727.  
  728.     Object tmp_form = form;
  729.     int abstract_class = 0, abstract_concrete_seen = 0;
  730.     int open_class = 0, open_sealed_seen = 0;
  731.     int primary_class = 0, primary_free_seen = 0;
  732.  
  733.     if (NULLP (CDR (tmp_form))) {
  734.     error ("malfored define-class (no arguments)", form, NULL);
  735.     }
  736.     tmp_form = CDR (tmp_form);
  737.     if (PAIRP (CAR (tmp_form))) {
  738.     modifiers = CAR (tmp_form);
  739.     if (CAR (modifiers) != modifiers_keyword) {
  740.         error ("malformed define-class (bad modifiers)", form, NULL);
  741.     }
  742.     for (modifiers = CDR (modifiers);
  743.          PAIRP (modifiers);
  744.          modifiers = CDR (modifiers)) {
  745.         modifier = CAR (modifiers);
  746.         if (modifier == abstract_symbol || modifier == concrete_symbol) {
  747.         if (abstract_concrete_seen) {
  748.             error ("redundant or conflicting modifier given to define-class",
  749.                modifier, NULL);
  750.         }
  751.         abstract_concrete_seen = 1;
  752.         abstract_class = (modifier == abstract_symbol);
  753.         }
  754.         if (modifier == primary_symbol || modifier == free_symbol) {
  755.         if (primary_free_seen) {
  756.             error ("redundant or conflicting modifier given to define-class",
  757.                modifier, NULL);
  758.         }
  759.         primary_free_seen = 1;
  760.         primary_class = (modifier == primary_symbol);
  761.         }
  762.         if (modifier == open_symbol || modifier == sealed_symbol) {
  763.         if (open_sealed_seen) {
  764.             error ("redundant or conflicting modifier given to define-class",
  765.                modifier, NULL);
  766.         }
  767.         open_sealed_seen = 1;
  768.         open_class = (modifier == open_symbol);
  769.         }
  770.     }
  771.     tmp_form = CDR (tmp_form);
  772.  
  773.     }
  774.     name = CAR (tmp_form);
  775.     tmp_form = CDR (tmp_form);
  776.     if (NULLP (tmp_form)) {
  777.     error ("malformed define-class (no superclass)", form, NULL);
  778.     }
  779.     /*
  780.      * Must introduce binding for the class before eval'ing the slot definitions.
  781.      */
  782.     obj = allocate_object (sizeof (struct class));
  783.  
  784.     CLASSTYPE (obj) = Class;
  785.     CLASSNAME (obj) = name;
  786.     add_top_level_binding (name, obj, 0);
  787.     supers = map (eval, CAR (tmp_form));
  788.     slots = slot_descriptor_list (CDR (tmp_form), 1);
  789.     make_getter_setter_gfs (slots);
  790.     class = make_class (obj, supers, slots, NULL);
  791.  
  792.     /* kludge to put these here.  Better to add a param to make_class. */
  793.     CLASSPROPS (class) |= CLASSSLOTSUNINIT;
  794.  
  795.     if (abstract_class) {
  796.     make_uninstantiable (class);
  797.     }
  798.     if (!open_class) {
  799. /*
  800.  * Need to address sealed vs. open classes with library additions.
  801.  */
  802. /*
  803.    seal (class);
  804.  */
  805.     }
  806.     if (primary_class) {
  807.     make_primary (class);
  808.     }
  809.     return (name);
  810. }
  811.  
  812. static Object
  813. define_generic_function_eval (Object form)
  814. {
  815.     Object name, params, gf;
  816.  
  817.     if (NULLP (CDR (form))) {
  818.     error ("define-generic-function: missing name", form, NULL);
  819.     }
  820.     name = SECOND (form);
  821.     if (NULLP (CDR (CDR (form)))) {
  822.     error ("define-generic-function: missing parameters", form, NULL);
  823.     }
  824.     params = THIRD (form);
  825.  
  826.     gf = make_generic_function (name, params, make_empty_list ());
  827.     add_top_level_binding (name, gf, 0);
  828.     return (unspecified_object);
  829. }
  830.  
  831. static Object
  832. define_method_eval (Object form)
  833. {
  834.     Object name, params, body, method, gf;
  835.  
  836.     if (NULLP (CDR (form))) {
  837.     error ("define-method: missing name", form, NULL);
  838.     }
  839.     name = SECOND (form);
  840.     if (!SYMBOLP (name)) {
  841.     error ("define-method: first argument must be a symbol", name, NULL);
  842.     }
  843.     if (NULLP (CDR (CDR (form)))) {
  844.     error ("define-method: missing parameter list", form, NULL);
  845.     }
  846.     params = THIRD (form);
  847.     if (!LISTP (params)) {
  848.     error ("define-method: second argument must be a parameter list", params, NULL);
  849.     }
  850.     body = CDR (CDR (CDR (form)));
  851.     method = make_method (name, params, body, the_env, 1);
  852.     return (name);
  853. }
  854.  
  855. static Object
  856. define_module_eval (Object form)
  857. {
  858.     Object clauses, clause;
  859.     Object module_name;
  860.     Object option;
  861.     struct module_binding *the_module;
  862.  
  863.     /* Bogus for now */
  864.     if (PAIRP (form) && list_length (form) >= 2 && SYMBOLP (SECOND (form))) {
  865.     the_module = new_module (SECOND (form));
  866.     clauses = CDR (CDR (form));
  867.  
  868.     while (PAIRP (clauses)) {
  869.         clause = CAR (clauses);
  870.         if (PAIRP (clause)) {
  871.         if (CAR (clause) == use_symbol) {
  872.             Object imports = all_symbol;
  873.             Object exclusions = make_empty_list ();
  874.             Object prefix = empty_string;
  875.             Object renames = make_empty_list ();
  876.             Object exports = make_empty_list ();
  877.  
  878.             int imports_specified = 0;
  879.             int exclusions_specified = 0;
  880.             int prefix_specified = 0;
  881.             int renames_specified = 0;
  882.             int exports_specified = 0;
  883.             struct module_binding *old_module;
  884.  
  885.             if (list_length (clause) >= 2) {
  886.             module_name = SECOND (clause);
  887.             clause = CDR (CDR (clause));
  888.             while (PAIRP (clause)) {
  889.                 option = CAR (clause);
  890.                 if (PAIRP (option)) {
  891.                 if (CAR (option) == import_keyword &&
  892.                     !imports_specified) {
  893.                     imports = CDR (option);
  894.                     imports_specified = 1;
  895.                 } else if (CAR (option) == exclude_keyword &&
  896.                        !exclusions_specified) {
  897.                     exclusions = CDR (option);
  898.                     exclusions_specified = 1;
  899.                 } else if (CAR (option) == prefix_keyword &&
  900.                        !prefix_specified) {
  901.                     prefix = CDR (option);
  902.                     prefix_specified = 1;
  903.                 } else if (CAR (option) == rename_keyword &&
  904.                        !renames_specified) {
  905.                     renames = CDR (option);
  906.                     renames_specified = 1;
  907.                 } else if (CAR (option) == export_keyword &&
  908.                        !exports_specified) {
  909.                     exports = CDR (option);
  910.                     exports_specified = 1;
  911.                 } else {
  912.                     error ("use clause: unknown option",
  913.                        option,
  914.                        NULL);
  915.                 }
  916.  
  917.                 } else {
  918.                 error ("use clause: poorly formed option",
  919.                        CAR (clause),
  920.                        NULL);
  921.                 }
  922.                 clause = CDR (clause);
  923.             }
  924.             if (imports_specified && exclusions_specified) {
  925.                 error ("Define module: Can't specify both imports: and exclusions:",
  926.                    clause,
  927.                    NULL);
  928.             }
  929.             old_module = set_module (the_module);
  930.             use_module (module_name,
  931.                     imports,
  932.                     exclusions,
  933.                     prefix,
  934.                     renames,
  935.                     exports);
  936.             set_module (old_module);
  937.             } else {
  938.             error ("define-module: Bad use clause",
  939.                    clause,
  940.                    NULL);
  941.             }
  942.         } else if (CAR (clause) == export_symbol) {
  943.             fill_table_from_property_set (the_module->exported_bindings,
  944.                           CDR (clause));
  945.         } else if (CAR (clause) == create_symbol) {
  946.             /*
  947.              * Aside from this, it's not clear to me (jnw) what
  948.              * needs to be done for create clause.
  949.              */
  950.             fill_table_from_property_set (the_module->exported_bindings,
  951.                           CDR (clause));
  952.         } else {
  953.             error ("define-module: Bad clause",
  954.                clause,
  955.                NULL);
  956.         }
  957.         } else {
  958.         error ("define-module: Bad clause",
  959.                clause,
  960.                NULL);
  961.         }
  962.         clauses = CDR (clauses);
  963.     }
  964.     } else {
  965.     error ("define-module: Bad argument list",
  966.            form,
  967.            NULL);
  968.     }
  969.     return unspecified_object;
  970. }
  971.  
  972. static Object
  973. dotimes_eval (Object form)
  974. {
  975.     Object clause, var, intval, resform, body, res;
  976.     int i;
  977.  
  978.     if (NULLP (CDR (form))) {
  979.     error ("malformed dotimes expression", form, NULL);
  980.     }
  981.     clause = CAR (CDR (form));
  982.     if (!PAIRP (clause)) {
  983.     error ("second arg to dotimes must be a list", clause, NULL);
  984.     }
  985.     var = CAR (clause);
  986.     if (!SYMBOLP (var)) {
  987.     error ("dotimes: first value in spec clause must be a symbol", var, NULL);
  988.     }
  989.     if (NULLP (CDR (clause))) {
  990.     error ("dotimes: must specifiy an upper bound", form, NULL);
  991.     }
  992.     intval = eval (CAR (CDR (clause)));
  993.     if (!INTEGERP (intval)) {
  994.     error ("dotimes: upper bound must an integer", intval, NULL);
  995.     }
  996.     if (!NULLP (CDR (CDR (clause)))) {
  997.     resform = CAR (CDR (CDR (clause)));
  998.     } else {
  999.     resform = NULL;
  1000.     }
  1001.  
  1002.     push_scope (CAR (form));
  1003.     add_binding (var, false_object, 0);
  1004.     for (i = 0; i < INTVAL (intval); ++i) {
  1005.     change_binding (var, make_integer (i));
  1006.     body = CDR (CDR (form));
  1007.     while (!NULLP (body)) {
  1008.         res = eval (CAR (body));
  1009.         body = CDR (body);
  1010.     }
  1011.     }
  1012.     if (resform) {
  1013.     res = eval (resform);
  1014.     } else {
  1015.     res = false_object;
  1016.     }
  1017.     pop_scope ();
  1018.     return (res);
  1019. }
  1020.  
  1021.  
  1022.  
  1023. static Object
  1024. for_eval (Object form)
  1025. {
  1026.     /* The classic syntax of a for is
  1027.  
  1028.      *  (for ((var-name-1 init-1 step-1) ... (var-name-2 init-2 step-2))
  1029.      *       (test result-1 ... result-n)
  1030.      *       expr-1 ... expr-n)
  1031.      *
  1032.      * We have to get the new syntax into a mild variant of this
  1033.      * original form.  The new syntax is
  1034.      *
  1035.      *  'for' ( clauses [{'until' | 'while'} end-test] )
  1036.      *    body
  1037.      *    ['finally' result-body]
  1038.      *  'end' ['for'] into this form.
  1039.      *
  1040.      * Where each of the `clauses' is of one of the following forms:
  1041.      *
  1042.      *  variable '=' init-value 'then' next-value
  1043.      *  variable 'in' collection
  1044.      *  variable 'from' start [{ 'to' | 'above' | 'below'} bound]
  1045.      *                        ['by' increment]
  1046.      *
  1047.      * Note that a variable is either
  1048.      *  variable-name or
  1049.      *  '(' variable-name '::' type ')'
  1050.      *
  1051.      * I decided to change the underlying form as follows:
  1052.      *
  1053.      * ('for' (clause-1 ... clause-n)
  1054.      *        (test result-1 result-n)
  1055.      *        expr-1 ... expr-n)
  1056.      *
  1057.      * Where clause-1 ... clause-n are each of the form
  1058.      *
  1059.      *  (variable init step)
  1060.      *  ('collection:' variable collection)
  1061.      *  ('range:' variable start [{'to' | 'above' | 'below'} bound]
  1062.      *                           ['by' increment])
  1063.      *
  1064.      * A 'while' specification will cause the end-test to be logically
  1065.      * negated in the generated for.
  1066.      * The result-body of the 'finally' specification shall provide the
  1067.      * single result expression.
  1068.      *
  1069.      * Some extra work is done to achieve compliance with the rules concerning
  1070.      * evaluation order of the expressions and availability of the variables
  1071.      * in the result-body.
  1072.      */
  1073.  
  1074.     Object var_forms, var_form, test_form, return_forms;
  1075.     Object var, clause_types, vars, inits, body, ret, new_vals;
  1076.  
  1077.     if ((!PAIRP (CDR (form))) ||
  1078.     (!PAIRP (CDR (CDR (form)))) ||
  1079.     (!PAIRP (THIRD (form)))) {
  1080.     error ("malformed FOR", form, NULL);
  1081.     }
  1082.     test_form = FIRST (THIRD (form));
  1083.     return_forms = CDR (THIRD (form));
  1084.  
  1085.     var_forms = SECOND (form);
  1086.  
  1087.     /* IRM Pg. 33 Step 1 */
  1088.  
  1089.     clause_types = vars = inits = make_empty_list ();
  1090.  
  1091.     get_vars_and_inits (var_forms, &clause_types, &vars, &inits);
  1092.  
  1093.     /* IRM Step 2 */
  1094.     push_scope (CAR (form));
  1095.     initialize_step_and_numeric_vars (clause_types, vars, inits);
  1096.  
  1097.     /* IRM Step 3 */
  1098.     initialize_collection_inits (clause_types, vars, inits);
  1099.     if (!exhausted_numeric_or_collection_clauses (clause_types,
  1100.                           vars,
  1101.                           inits,
  1102.                           1)) {
  1103.  
  1104.     /* IRM Step 4 */
  1105.  
  1106.     push_scope (CAR (form));
  1107.     initialize_collection_variables (clause_types, vars, inits);
  1108.  
  1109.     do {
  1110.         /* IRM Step 5 */
  1111.         if (eval (test_form) == true_object) {
  1112.         break;
  1113.         }
  1114.         /* IRM Step 6 */
  1115.         body = CDR (CDR (CDR (form)));
  1116.         while (!NULLP (body)) {
  1117.         eval (CAR (body));
  1118.         body = CDR (body);
  1119.         }
  1120.  
  1121.         /* IRM Steps 7 and 8 */
  1122.         update_explicit_and_numeric_clauses (clause_types,
  1123.                          vars,
  1124.                          inits);
  1125.  
  1126.         /* IRM Step 3 (again) */
  1127.         if (exhausted_numeric_or_collection_clauses (clause_types,
  1128.                              vars,
  1129.                              inits,
  1130.                              0)) {
  1131.         break;
  1132.         }
  1133.         update_collection_variables (clause_types, vars, inits);
  1134.     } while (1);
  1135.     pop_scope ();        /* To get rid of collection variables */
  1136.     }
  1137.     if (!PAIRP (return_forms)) {
  1138.     ret = false_object;
  1139.     } else {
  1140.     while (PAIRP (return_forms)) {
  1141.         ret = eval (CAR (return_forms));
  1142.         return_forms = CDR (return_forms);
  1143.     }
  1144.     }
  1145.     pop_scope ();
  1146.     return ret;
  1147. }
  1148.  
  1149. static Object
  1150. get_variable (Object var_spec)
  1151. {
  1152.     Object res;
  1153.  
  1154.     if ((PAIRP (var_spec) && (list_length (var_spec) != 2)) &&
  1155.     (!SYMBOLP (var_spec))) {
  1156.     error ("Bad variable specification", var_spec, NULL);
  1157.     }
  1158.     return var_spec;
  1159. }
  1160.  
  1161. static Object
  1162. variable_name (Object var_spec)
  1163. {
  1164.     return (PAIRP (var_spec)) ? CAR (var_spec) : var_spec;
  1165. }
  1166.  
  1167. static void
  1168. get_vars_and_inits (Object var_forms,
  1169.             Object *clause_types_ptr,
  1170.             Object *vars_ptr,
  1171.             Object *inits_ptr)
  1172. {
  1173.     Object var_form, var_spec;
  1174.     Object clause_type, var, init;
  1175.     Object rest, by, start, termination, bound, negative;
  1176.  
  1177.     while (PAIRP (var_forms)) {
  1178.     var_form = CAR (var_forms);
  1179.     var_spec = CAR (var_form);
  1180.     if (PAIRP (var_spec) || SYMBOLP (var_spec)) {
  1181.  
  1182.         /* Explicit Step Clause: init is of form
  1183.          *    (init-value . next-value)
  1184.          */
  1185.  
  1186.         clause_type = variable_keyword;
  1187.         var = get_variable (var_spec);
  1188.         if (list_length (var_form) != 3) {
  1189.         error ("for: Bad variable initialization",
  1190.                var_form,
  1191.                NULL);
  1192.         }
  1193.         init = cons (eval (SECOND (var_form)), THIRD (var_form));
  1194.     } else if (var_spec == range_keyword) {
  1195.  
  1196.         /* Numeric Clause: init is of form
  1197.          * (start-value increment negative termination bound)
  1198.          *
  1199.          * negative is #t is increment < 0, #f otherwise
  1200.          * termination is to:, above:, or below:
  1201.          */
  1202.  
  1203.         clause_type = range_keyword;
  1204.         if (list_length (var_form) < 3) {
  1205.         error ("for: Bad numeric clause specification", var_form, NULL);
  1206.         }
  1207.         var = get_variable (SECOND (var_form));
  1208.         rest = CDR (CDR (var_form));
  1209.  
  1210.         by = make_integer (1);
  1211.         termination = false_object;
  1212.         start = eval (CAR (rest));
  1213.         rest = CDR (rest);
  1214.         bound = false_object;
  1215.         if (PAIRP (rest)) {
  1216.         termination = CAR (rest);
  1217.         if (PAIRP (CDR (rest)) &&
  1218.          (termination == to_symbol || termination == above_symbol ||
  1219.           termination == below_symbol)) {
  1220.             bound = CAR (CDR (rest));
  1221.             rest = CDR (CDR (rest));
  1222.         } else {
  1223.             error ("for: badly formed numeric clause", var_form, NULL);
  1224.         }
  1225.         }
  1226.         if (PAIRP (rest)) {
  1227.         if (PAIRP (CDR (rest)) && CAR (rest) == by_symbol) {
  1228.             by = eval (CAR (CDR (rest)));
  1229.         } else {
  1230.             error ("for: badly formed numeric clause", var_form, NULL);
  1231.         }
  1232.         }
  1233.         switch (TYPE (by)) {
  1234.         case Integer:
  1235.         negative = (INTVAL (by) >= 0) ? false_object : true_object;
  1236.         break;
  1237.         case DoubleFloat:
  1238.         negative = (DFLOATVAL (by) >= 0) ? false_object : true_object;
  1239.         break;
  1240.         default:
  1241.         error ("for: numeric clause has unsupported increment type",
  1242.                by,
  1243.                NULL);
  1244.         }
  1245.  
  1246.         init = listem (start, by, negative, termination, bound, NULL);
  1247.  
  1248.     } else if (var_spec == collection_keyword) {
  1249.  
  1250.         /* Collection Clause: init value is
  1251.          *  (protocol collection state)
  1252.          */
  1253.  
  1254.         clause_type = collection_keyword;
  1255.         if (list_length (var_form) != 3) {
  1256.         error ("for: Bad collection clause specification",
  1257.                var_form,
  1258.                NULL);
  1259.         }
  1260.         var = get_variable (SECOND (var_form));
  1261.         init = listem (make_empty_list (),
  1262.                eval (THIRD (var_form)),
  1263.                make_empty_list (),
  1264.                NULL);
  1265.     }
  1266.     *clause_types_ptr = cons (clause_type, make_empty_list ());
  1267.     *vars_ptr = cons (var, make_empty_list ());
  1268.     *inits_ptr = cons (init, make_empty_list ());
  1269.  
  1270.     clause_types_ptr = &CDR (*clause_types_ptr);
  1271.     vars_ptr = &CDR (*vars_ptr);
  1272.     inits_ptr = &CDR (*inits_ptr);
  1273.  
  1274.     var_forms = CDR (var_forms);
  1275.     }
  1276. }
  1277.  
  1278. static void
  1279. initialize_step_and_numeric_vars (Object clause_types,
  1280.                   Object vars,
  1281.                   Object inits)
  1282. {
  1283.     Object clause_type;
  1284.  
  1285.     while (PAIRP (clause_types)) {
  1286.     if (CAR (clause_types) == variable_keyword) {
  1287.         /* explicit step clause */
  1288.         add_binding (CAR (vars), CAR (CAR (inits)), 0);
  1289.     } else if (CAR (clause_types) == range_keyword) {
  1290.         add_binding (CAR (vars), CAR (CAR (inits)), 0);
  1291.     }
  1292.     clause_types = CDR (clause_types);
  1293.     vars = CDR (vars);
  1294.     inits = CDR (inits);
  1295.     }
  1296. }
  1297.  
  1298. /*
  1299.  * Surgically alters `inits'!
  1300.  * Stuffs the forward-iteration-protocol for the numeric and collection
  1301.  * clauses into the CAR of the corresponding init.
  1302.  */
  1303. static void
  1304. initialize_collection_inits (Object clause_types,
  1305.                  Object vars,
  1306.                  Object inits)
  1307. {
  1308.     Object clause_type, protocol;
  1309.  
  1310.     while (PAIRP (clause_types)) {
  1311.     clause_type = CAR (clause_types);
  1312.     if (clause_type == collection_keyword) {
  1313.         protocol = eval (cons (forward_iteration_protocol_symbol,
  1314.                    cons (cons (quote_symbol,
  1315.                            cons (SECOND (CAR (inits)),
  1316.                              make_empty_list ())),
  1317.                      make_empty_list ())));
  1318.         CAR (CAR (inits)) = protocol;
  1319.         THIRD (CAR (inits)) = VALUESELS (protocol)[0];
  1320.     }
  1321.     clause_types = CDR (clause_types);
  1322.     vars = CDR (vars);
  1323.     inits = CDR (inits);
  1324.     }
  1325. }
  1326.  
  1327.  
  1328. /*
  1329.  * Evaluates finished-state (value 3) applied to collection
  1330.  * initial-state (value 0) and limit (value 0) to determine whether or
  1331.  * not the collection is exhausted.
  1332.  */
  1333.  
  1334.  
  1335. static int
  1336. exhausted_numeric_or_collection_clauses (Object clause_types,
  1337.                      Object vars,
  1338.                      Object inits,
  1339.                      int init_call)
  1340. {
  1341.     Object clause_type;
  1342.     Object protocol;
  1343.     Object init, current, increment, negative, termination, bound;
  1344.  
  1345.     while (PAIRP (clause_types)) {
  1346.     clause_type = CAR (clause_types);
  1347.     if (clause_type == collection_keyword) {
  1348.         protocol = FIRST (CAR (inits));
  1349.  
  1350.         /* (finished-state? collection state limit) */
  1351.         if (!init_call) {
  1352.         /* Bump to the next state to see if it exists */
  1353.         THIRD (CAR (inits)) = apply (VALUESELS (protocol)[2],
  1354.                          cons (SECOND (CAR (inits)),
  1355.                            cons (THIRD (CAR (inits)),
  1356.                               make_empty_list ())));
  1357.         }
  1358.         if (true_object == apply (VALUESELS (protocol)[3],
  1359.                       cons (SECOND (CAR (inits)),
  1360.                         cons (THIRD (CAR (inits)),
  1361.                           cons (VALUESELS (protocol)[1],
  1362.                             make_empty_list ()))))) {
  1363.         return 1;
  1364.         }
  1365.     } else if (clause_type == range_keyword) {
  1366.  
  1367.         init = CAR (inits);
  1368.         current = CAR (init);    /* FIRST */
  1369.         init = CDR (init);
  1370.         increment = CAR (init);    /* SECOND */
  1371.         init = CDR (init);
  1372.         negative = CAR (init);    /* THIRD */
  1373.         init = CDR (init);
  1374.         termination = CAR (init);    /* FOURTH */
  1375.         init = CDR (init);
  1376.         bound = CAR (init);    /* FIFTH */
  1377.  
  1378.         if (termination == false_object) {
  1379.         /* do nothing */
  1380.         } else if (termination == to_symbol) {
  1381.         if (negative == true_object) {
  1382.             if (true_object == eval (listem (lesser_symbol,
  1383.                              current,
  1384.                              bound,
  1385.                              NULL))) {
  1386.             return 1;
  1387.             }
  1388.         } else if (true_object == eval (listem (greater_symbol,
  1389.                             current,
  1390.                             bound,
  1391.                             NULL))) {
  1392.             return 1;
  1393.         }
  1394.         } else if (termination == above_symbol) {
  1395.         if (true_object == eval (listem (lesser_equal_symbol,
  1396.                          current,
  1397.                          bound,
  1398.                          NULL))) {
  1399.             return 1;
  1400.         }
  1401.         } else if (termination == below_symbol) {
  1402.         if (true_object == eval (listem (greater_equal_symbol,
  1403.                          current,
  1404.                          bound,
  1405.                          NULL))) {
  1406.             return 1;
  1407.         }
  1408.         }
  1409.     }
  1410.     clause_types = CDR (clause_types);
  1411.     vars = CDR (vars);
  1412.     inits = CDR (inits);
  1413.     }
  1414.     return 0;
  1415. }
  1416.  
  1417.  
  1418. static void
  1419. initialize_collection_variables (Object clause_types,
  1420.                  Object vars,
  1421.                  Object inits)
  1422. {
  1423.     Object protocol;
  1424.  
  1425.     while (PAIRP (clause_types)) {
  1426.     if (CAR (clause_types) == collection_keyword) {
  1427.         protocol = FIRST (CAR (inits));
  1428.  
  1429.         /* (set! var (current-element collection state)) */
  1430.         add_binding (CAR (vars),
  1431.              apply (VALUESELS (protocol)[5],
  1432.                 cons (SECOND (CAR (inits)),
  1433.                       cons (THIRD (CAR (inits)),
  1434.                         make_empty_list ()))),
  1435.              0);
  1436.     }
  1437.     clause_types = CDR (clause_types);
  1438.     vars = CDR (vars);
  1439.     inits = CDR (inits);
  1440.     }
  1441. }
  1442.  
  1443. static void
  1444. update_explicit_and_numeric_clauses (Object clause_types,
  1445.                      Object vars,
  1446.                      Object inits)
  1447. {
  1448.     Object vars_copy, new_values, *new_values_ptr, new_value;
  1449.     Object clause_type;
  1450.  
  1451.     vars_copy = vars;
  1452.     new_values_ptr = &new_values;
  1453.  
  1454.     while (PAIRP (clause_types)) {
  1455.     new_value = make_empty_list ();
  1456.     clause_type = CAR (clause_types);
  1457.     if (clause_type == variable_keyword) {
  1458.         new_value = eval (CDR (CAR (inits)));
  1459.     } else if (clause_type == range_keyword) {
  1460.         /* Set new of var generated by range to
  1461.          *  (+ var increment)
  1462.          */
  1463.         new_value = eval (listem (plus_symbol,
  1464.                       variable_name (CAR (vars)),
  1465.                       SECOND (CAR (inits)),
  1466.                       NULL));
  1467.  
  1468.         FIRST (CAR (inits)) = new_value;
  1469.     }
  1470.     *new_values_ptr = cons (new_value, make_empty_list ());
  1471.  
  1472.     new_values_ptr = &CDR (*new_values_ptr);
  1473.     clause_types = CDR (clause_types);
  1474.     vars = CDR (vars);
  1475.     inits = CDR (inits);
  1476.  
  1477.     }
  1478.  
  1479.     /* Do the bindings */
  1480.     while (PAIRP (vars_copy)) {
  1481.     if (!EMPTYLISTP (new_values)) {
  1482.         modify_value (variable_name (CAR (vars_copy)),
  1483.               CAR (new_values));
  1484.         vars_copy = CDR (vars_copy);
  1485.         new_values = CDR (new_values);
  1486.     }
  1487.     }
  1488. }
  1489.  
  1490. static void
  1491. update_collection_variables (Object clause_types,
  1492.                  Object vars,
  1493.                  Object inits)
  1494. {
  1495.     Object protocol, new_value;
  1496.  
  1497.     while (PAIRP (clause_types)) {
  1498.     if (CAR (clause_types) == collection_keyword) {
  1499.         protocol = FIRST (CAR (inits));
  1500.  
  1501.         /* (set! var (current-element collection state)) */
  1502.         modify_value (CAR (vars),
  1503.               apply (VALUESELS (protocol)[5],
  1504.                  cons (SECOND (CAR (inits)),
  1505.                        cons (THIRD (CAR (inits)),
  1506.                          make_empty_list ()))));
  1507.     }
  1508.     clause_types = CDR (clause_types);
  1509.     vars = CDR (vars);
  1510.     inits = CDR (inits);
  1511.     }
  1512. }
  1513.  
  1514. /*
  1515.    The iteration is terminated if any collection is exhausted 
  1516.    (in which case #f is returned) or if the end-test evaluates 
  1517.    to #t (in which case the result forms are evaluated and the
  1518.    value of the last is returned).
  1519.  */
  1520. static Object
  1521. for_each_eval (Object form)
  1522. {
  1523.     Object test_form, return_forms, var_forms;
  1524.     Object vars, collections, states, vals, body, ret, temp_vars;
  1525.     Object init_state_fun, next_state_fun, cur_el_fun;
  1526.  
  1527.     init_state_fun = symbol_value (initial_state_sym);
  1528.     if (!init_state_fun) {
  1529.     error ("for-each: no initial-state function defined", NULL);
  1530.     }
  1531.     next_state_fun = symbol_value (next_state_sym);
  1532.     if (!next_state_fun) {
  1533.     error ("for-each: no next-state function defined", NULL);
  1534.     }
  1535.     cur_el_fun = symbol_value (current_element_sym);
  1536.     if (!cur_el_fun) {
  1537.     error ("for-each: no current-element function defined", NULL);
  1538.     }
  1539.     if (NULLP (CDR (form))) {
  1540.     error ("malformed FOR-EACH", form, NULL);
  1541.     }
  1542.     if (NULLP (CDR (CDR (form)))) {
  1543.     error ("malformed FOR-EACH", form, NULL);
  1544.     }
  1545.     test_form = FIRST (THIRD (form));
  1546.     return_forms = CDR (THIRD (form));
  1547.  
  1548.     var_forms = SECOND (form);
  1549.     vars = map (car, var_forms);
  1550.     collections = map (second, var_forms);
  1551.     collections = map (eval, collections);
  1552.     states = list_map1 (init_state_fun, collections);
  1553.  
  1554.     if (member (false_object, states)) {
  1555.     return (false_object);
  1556.     }
  1557.     vals = list_map2 (cur_el_fun, collections, states);
  1558.     push_scope (CAR (form));
  1559.     add_bindings (vars, vals, 0);
  1560.  
  1561.     while (eval (test_form) == false_object) {
  1562.     body = CDR (CDR (CDR (form)));
  1563.     while (!NULLP (body)) {
  1564.         eval (CAR (body));
  1565.         body = CDR (body);
  1566.     }
  1567.     states = list_map2 (next_state_fun, collections, states);
  1568.     if (member (false_object, states)) {
  1569.         pop_scope ();
  1570.         return (false_object);
  1571.     }
  1572.     vals = list_map2 (cur_el_fun, collections, states);
  1573.  
  1574.     /* modify bindings */
  1575.     temp_vars = vars;
  1576.     while (!NULLP (temp_vars)) {
  1577.         modify_value (CAR (temp_vars), CAR (vals));
  1578.         temp_vars = CDR (temp_vars);
  1579.         vals = CDR (vals);
  1580.     }
  1581.     }
  1582.  
  1583.     if (NULLP (return_forms)) {
  1584.     return (false_object);
  1585.     } else {
  1586.     ret = eval_body (return_forms, false_object);
  1587.     }
  1588.     pop_scope ();
  1589.     return (ret);
  1590. }
  1591.  
  1592. static Object
  1593. if_eval (Object form)
  1594. {
  1595.     Object testval, thenform, elseform;
  1596.  
  1597.     if (NULLP (CDR (form))) {
  1598.     error ("malformed if expression", form, NULL);
  1599.     }
  1600.     testval = SECOND (form);
  1601.     if (NULLP (CDR (CDR (form)))) {
  1602.     error ("malformed if expression", form, NULL);
  1603.     }
  1604.     thenform = THIRD (form);
  1605.     if (NULLP (CDR (CDR (CDR (form))))) {
  1606.     error ("if expression must have else clause", form, NULL);
  1607.     }
  1608.     elseform = FOURTH (form);
  1609.     if (!NULLP (CDR (CDR (CDR (CDR (form)))))) {
  1610.     error ("if: too many arguments", NULL);
  1611.     }
  1612.     testval = eval (testval);
  1613.  
  1614.     if (testval == false_object) {
  1615.     return tail_eval (elseform);
  1616.     } else {
  1617.     return tail_eval (thenform);
  1618.     }
  1619. }
  1620.  
  1621. static Object
  1622. method_eval (Object form)
  1623. {
  1624.     Object params, body, method;
  1625.  
  1626.     if (NULLP (CDR (form))) {
  1627.     error ("method: missing parameters", form, NULL);
  1628.     }
  1629.     params = SECOND (form);
  1630.     body = CDR (CDR (form));
  1631.     method = make_method (NULL, params, body, the_env, 0);
  1632.     return (method);
  1633. }
  1634.  
  1635. static Object
  1636. or_eval (Object form)
  1637. {
  1638.     Object clauses, ret;
  1639.  
  1640.     clauses = CDR (form);
  1641.     while (!NULLP (clauses)) {
  1642.     if (EMPTYLISTP (CDR (clauses))) {
  1643.         return tail_eval (CAR (clauses));
  1644.     }
  1645.     ret = eval (CAR (clauses));
  1646.     if (VALUESP (ret)) {
  1647.         if (PAIRP (CDR (clauses))) {
  1648.         ret = FIRSTVAL (ret);
  1649.         } else {
  1650.         return (ret);
  1651.         }
  1652.     }
  1653.     if (ret != false_object) {
  1654.         return (ret);
  1655.     }
  1656.     clauses = CDR (clauses);
  1657.     }
  1658.     return (false_object);
  1659. }
  1660.  
  1661. static Object qq_help (Object skel);
  1662.  
  1663. static Object
  1664. quasiquote_eval (Object form)
  1665. {
  1666.     return qq_help (SECOND (form));
  1667. }
  1668.  
  1669. static Object
  1670. qq_help (Object skel)
  1671. {
  1672.     Object head, tmp, tail;
  1673.  
  1674.     if (NULLP (skel) || SYMBOLP (skel) || !PAIRP (skel)) {
  1675.     return skel;
  1676.     } else {
  1677.     head = skel;
  1678.     tail = CDR (skel);
  1679.     if (CAR (head) == unquote_symbol) {
  1680.         if (!NULLP (tail)) {
  1681.         if (!NULLP (CDR (tail))) {
  1682.             error ("Too many arguments to unquote", NULL);
  1683.         }
  1684.         return eval (CAR (tail));
  1685.         } else {
  1686.         error ("missing argument to unquote", NULL);
  1687.         }
  1688.     } else if (PAIRP (CAR (head))
  1689.            && CAR (CAR (head)) == unquote_splicing_symbol) {
  1690.  
  1691.         if (!NULLP (CDR (CAR (head)))) {
  1692.         tmp = eval (CAR (CDR (CAR (head))));
  1693.         CAR (head) = CAR (tmp);
  1694.         CDR (head) = CDR (tmp);
  1695.         tmp = head;
  1696.         while (!NULLP (CDR (tmp))) {
  1697.             tmp = CDR (tmp);
  1698.         }
  1699.         CDR (tmp) = qq_help (tail);
  1700.         return head;
  1701.         } else {
  1702.         error ("missing argument to unquote_splicing", NULL);
  1703.         }
  1704.     } else {
  1705.         return cons (qq_help (CAR (head)), qq_help (tail));
  1706.     }
  1707.     }
  1708. }
  1709.  
  1710. static Object
  1711. quote_eval (Object form)
  1712. {
  1713.     return (SECOND (form));
  1714. }
  1715.  
  1716. static Object
  1717. select_eval (Object form)
  1718. {
  1719.     Object target_form, test, branches, branch;
  1720.     Object match_list, consequents, ret;
  1721.  
  1722.     if (NULLP (CDR (form))) {
  1723.     error ("malformed select", form, NULL);
  1724.     }
  1725.     target_form = eval (CAR (CDR (form)));
  1726.  
  1727.     if (NULLP (CDR (CDR (form)))) {
  1728.     error ("malformed select", form, NULL);
  1729.     }
  1730.     test = eval (CAR (CDR (CDR (form))));
  1731.  
  1732.     if (NULLP (CDR (CDR (CDR (form))))) {
  1733.     error ("malformed select", form, NULL);
  1734.     }
  1735.     branches = CDR (CDR (CDR (form)));
  1736.     while (!NULLP (branches)) {
  1737.     branch = CAR (branches);
  1738.     if (!PAIRP (branch)) {
  1739.         error ("select: malformed branch", branch, NULL);
  1740.     }
  1741.     match_list = CAR (branch);
  1742.     if ((match_list == true_object) || (match_list == else_keyword)) {
  1743.         consequents = CDR (branch);
  1744.         while (!NULLP (consequents)) {
  1745.         ret = eval (CAR (consequents));
  1746.         consequents = CDR (consequents);
  1747.         }
  1748.         return (ret);
  1749.     }
  1750.     if (!PAIRP (match_list)) {
  1751.         error ("select: malformed test expression", match_list, NULL);
  1752.     }
  1753.     while (!NULLP (match_list)) {
  1754.         ret = false_object;
  1755.         if (apply (test, listem (target_form, eval (CAR (match_list)),
  1756.                      NULL)) != false_object) {
  1757.         consequents = CDR (branch);
  1758.         while (!NULLP (consequents)) {
  1759.             ret = eval (CAR (consequents));
  1760.             consequents = CDR (consequents);
  1761.         }
  1762.         return (ret);
  1763.         }
  1764.         match_list = CDR (match_list);
  1765.     }
  1766.     branches = CDR (branches);
  1767.     }
  1768.     return (false_object);
  1769. }
  1770.  
  1771. static Object
  1772. set_eval (Object form)
  1773. {
  1774.     Object sym, val, setter_sym;
  1775.  
  1776.     if (NULLP (CDR (form))) {
  1777.     error ("set!: missing forms", form, NULL);
  1778.     }
  1779.     sym = SECOND (form);
  1780.  
  1781.     if (PAIRP (sym)) {
  1782.     /*
  1783.      * <pcb> let's keep things in the spirit of the old language.
  1784.      * (set! (slot obj ...) new-value) should become
  1785.      * (slot-setter new-value obj ...)
  1786.      */
  1787.     return eval (cons (setter_sym,
  1788.                devalue (cons (THIRD (form), CDR (sym)))));
  1789.  
  1790.     }
  1791.     if (NULLP (CDR (CDR (form)))) {
  1792.     error ("set!: missing forms", form, NULL);
  1793.     }
  1794.     val = devalue (eval (THIRD (form)));
  1795.     modify_value (sym, val);
  1796.     return (val);
  1797. }
  1798.  
  1799. static Object
  1800. set_module_eval (Object form)
  1801. {
  1802.     if (PAIRP (form) && list_length (form) == 2 && KEYWORDP (SECOND (form))) {
  1803.     return user_set_module (devalue (CDR (form)));
  1804.     } else {
  1805.     error ("set_module: argument list not a single symbol",
  1806.            form,
  1807.            NULL);
  1808.     }
  1809.     return unspecified_object;
  1810. }
  1811.  
  1812. static Object
  1813. unless_eval (Object form)
  1814. {
  1815.     Object test, body, ret;
  1816.  
  1817.     if (NULLP (CDR (form))) {
  1818.     error ("unless: missing forms", form, NULL);
  1819.     }
  1820.     test = SECOND (form);
  1821.     body = CDR (CDR (form));
  1822.     if (eval (test) == false_object) {
  1823.     return (eval_body (body, false_object));
  1824.     }
  1825.     return (false_object);
  1826. }
  1827.  
  1828. static Object
  1829. until_eval (Object form)
  1830. {
  1831.     Object test, body, forms;
  1832.  
  1833.     if (NULLP (CDR (form))) {
  1834.     error ("malformed until statment", form, NULL);
  1835.     }
  1836.     test = CAR (CDR (form));
  1837.     body = CDR (CDR (form));
  1838.  
  1839.     while (eval (test) == false_object) {
  1840.     forms = body;
  1841.     while (!NULLP (forms)) {
  1842.         eval (CAR (forms));
  1843.         forms = CDR (forms);
  1844.     }
  1845.     }
  1846.     return (false_object);
  1847. }
  1848.  
  1849. static Object
  1850. unwind_protect_eval (Object form)
  1851. {
  1852.     Object protected, cleanups, unwind, ret;
  1853.  
  1854.     if (NULLP (CDR (form))) {
  1855.     error ("unwind-protect: missing forms", form, NULL);
  1856.     }
  1857.     protected = SECOND (form);
  1858.     cleanups = CDR (CDR (form));
  1859.     unwind = make_unwind (cleanups);
  1860.  
  1861.     push_scope (CAR (form));
  1862.     add_binding (unwind_symbol, unwind, 1);
  1863.     ret = eval (protected);
  1864.     pop_scope ();
  1865.     return (ret);
  1866. }
  1867.  
  1868. static Object
  1869. when_eval (Object form)
  1870. {
  1871.     Object test, body, ret;
  1872.  
  1873.     if (NULLP (CDR (form))) {
  1874.     error ("when: missing forms", form, NULL);
  1875.     }
  1876.     test = SECOND (form);
  1877.     body = CDR (CDR (form));
  1878.     if (eval (test) != false_object) {
  1879.     return eval_body (body, false_object);
  1880.     }
  1881.     return (false_object);
  1882. }
  1883.  
  1884. static Object
  1885. while_eval (Object form)
  1886. {
  1887.     Object test, body, forms;
  1888.  
  1889.     if (NULLP (CDR (form))) {
  1890.     error ("malformed while statment", form, NULL);
  1891.     }
  1892.     test = CAR (CDR (form));
  1893.     body = CDR (CDR (form));
  1894.  
  1895.     while (eval (test) != false_object) {
  1896.     forms = body;
  1897.     while (!NULLP (forms)) {
  1898.         eval (CAR (forms));
  1899.         forms = CDR (forms);
  1900.     }
  1901.     }
  1902.     return (false_object);
  1903. }
  1904.  
  1905. static Object ___passed_test_list;
  1906. static Object ___failed_test_list;
  1907. static Object ___disabled_test_list;
  1908. static Object ___failure_format_string;
  1909. static Object ___success_format_string;
  1910. static Object ___disabled_format_string;
  1911. static Object ___fail_symbol;
  1912. static Object ___pass_symbol;
  1913. static Object ___disabled_symbol;
  1914. static Object ___no_handler_symbol;
  1915. static Object ___signal_symbol;
  1916.  
  1917. static Object
  1918. define_test_eval (Object form)
  1919. {
  1920.     Object test_name, test_options, doc_string, test_form;
  1921.     Object exit_obj, ret;
  1922.     int old_no_debug = NoDebug;
  1923.     Object cache_env = the_env;
  1924.  
  1925.     NoDebug = 1;
  1926.  
  1927.     if (___passed_test_list == NULL) {
  1928.     ___passed_test_list = make_symbol ("*passed-test-list*");
  1929.     add_top_level_binding (___passed_test_list, make_empty_list (), 0);
  1930.  
  1931.     ___failed_test_list = make_symbol ("*failed-test-list*");
  1932.     add_top_level_binding (___failed_test_list, make_empty_list (), 0);
  1933.  
  1934.     ___disabled_test_list = make_symbol ("*disabled-test-list*");
  1935.     add_top_level_binding (___disabled_test_list, make_empty_list (), 0);
  1936.  
  1937.     ___failure_format_string =
  1938.         make_byte_string ("~%Failed:  ~A ~A with result ~A.");
  1939.     ___success_format_string =
  1940.         make_byte_string ("~%Passed:  ~A ~A with result ~A.");
  1941.     ___disabled_format_string =
  1942.         make_byte_string ("~%Disabled:  ~A ~A.");
  1943.     ___disabled_symbol = make_symbol ("disabled");
  1944.     ___fail_symbol = make_symbol ("fail");
  1945.     ___pass_symbol = make_symbol ("pass");
  1946.  
  1947.     ___disabled_symbol = make_keyword ("disabled:");
  1948.     ___no_handler_symbol = make_keyword ("no-handler:");
  1949.     ___signal_symbol = make_keyword ("signal:");
  1950.     }
  1951.     if (list_length (form) != 5) {
  1952.     error ("define-test: bad argument list", form);
  1953.     }
  1954.     form = CDR (form);
  1955.     test_name = CAR (form);
  1956.     form = CDR (form);
  1957.     test_options = CAR (form);
  1958.     form = CDR (form);
  1959.     doc_string = CAR (form);
  1960.     form = CDR (form);
  1961.     test_form = CAR (form);
  1962.  
  1963.     if (!SYMBOLP (test_name)) {
  1964.     error ("define-test: first argument must be the test name",
  1965.            test_name, NULL);
  1966.     }
  1967.     if (!LISTP (test_options)) {
  1968.     error ("define-test: second argument must be a list of options",
  1969.            test_options, NULL);
  1970.     }
  1971.     if (!BYTESTRP (doc_string)) {
  1972.     error ("define-test: third argument must be documenting string",
  1973.            doc_string, NULL);
  1974.     }
  1975.     if (doc_string == empty_string) {
  1976.     doc_string = find_keyword_val (description_symbol, test_options);
  1977.     if (doc_string == NULL)
  1978.         doc_string = empty_string;
  1979.     }
  1980.     if (member (___disabled_symbol, test_options)) {
  1981.     return record_disabled (test_name, doc_string);
  1982.     } else if (member (___no_handler_symbol, test_options)) {
  1983.     return process_test_result (test_name, map (eval, test_options),
  1984.                     doc_string, eval (test_form));
  1985.     } else {
  1986.     exit_obj = make_exit (signal_symbol);
  1987.     ret = (Object) setjmp (*EXITRET (exit_obj));
  1988.     push_scope (CAR (form));
  1989.     add_binding (signal_symbol, exit_obj, 1);
  1990.     if (!ret) {
  1991.         ret = eval (test_form);
  1992.         pop_scope ();
  1993.     } else {
  1994.         pop_scope ();
  1995.     }
  1996.     the_env = cache_env;
  1997.     NoDebug = old_no_debug;
  1998.     return process_test_result (test_name, map (eval, test_options),
  1999.                     doc_string, ret);
  2000.     }
  2001. }
  2002.  
  2003. static Object
  2004. process_test_result (Object name, Object options, Object doc_string,
  2005.              Object result)
  2006. {
  2007.     Object signal_opt;
  2008.  
  2009.     if (signal_opt = find_keyword_val (___signal_symbol, options)) {
  2010.     if (!instance (result, signal_opt)) {
  2011.         warning ("Signalled error class incorrect", signal_opt, NULL);
  2012.     }
  2013.     if (instance (result, error_class)) {
  2014.         return record_success (name, doc_string, result);
  2015.     }
  2016.     } else if (result == true_object) {
  2017.     return record_success (name, doc_string, result);
  2018.     } else {
  2019.     return record_failure (name, doc_string, result);
  2020.     }
  2021. }
  2022.  
  2023.  
  2024. static Object
  2025. record_failure (Object name, Object doc_string, Object result)
  2026. {
  2027.     struct frame *old_env = the_env;
  2028.  
  2029.     the_env = module_binding (dylan_user_symbol)->namespace;
  2030.  
  2031.     format (true_object, ___failure_format_string,
  2032.         listem (name, doc_string, result, NULL));
  2033.     modify_value (___failed_test_list,
  2034.           cons (name, symbol_value (___failed_test_list)));
  2035.     the_env = old_env;
  2036.     return ___fail_symbol;
  2037. }
  2038.  
  2039. static Object
  2040. record_success (Object name, Object doc_string, Object test_result)
  2041. {
  2042.     struct frame *old_env = the_env;
  2043.  
  2044.     the_env = module_binding (dylan_user_symbol)->namespace;
  2045.  
  2046.     format (true_object, ___success_format_string,
  2047.         listem (name, doc_string, test_result, NULL));
  2048.     modify_value (___passed_test_list,
  2049.           cons (name, symbol_value (___passed_test_list)));
  2050.     the_env = old_env;
  2051.     return ___pass_symbol;
  2052. }
  2053.  
  2054. static Object
  2055. record_disabled (Object name, Object doc_string)
  2056. {
  2057.     struct frame *old_env = the_env;
  2058.  
  2059.     the_env = module_binding (dylan_user_symbol)->namespace;
  2060.  
  2061.     format (true_object, ___disabled_format_string,
  2062.         listem (name, doc_string, NULL));
  2063.     modify_value (___disabled_test_list,
  2064.           cons (name, symbol_value (___disabled_test_list)));
  2065.     the_env = old_env;
  2066.     return ___disabled_symbol;
  2067. }
  2068.  
  2069. static Object
  2070. car (Object lst)
  2071. {
  2072.     return CAR (lst);
  2073. }
  2074.